home *** CD-ROM | disk | FTP | other *** search
/ Night Owl 9 / Night Owl CD-ROM (NOPV9) (Night Owl Publisher) (1993).ISO / 012a / lib194.zip / SCA.PRG < prev    next >
Text File  |  1992-12-23  |  16KB  |  404 lines
  1. *-------------------------------------------------------------------------------
  2. *-- Program...: SCA.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 06/25/1992
  5. *-- Notes.....: This file contains the SCA Date handling routines, as well as a
  6. *--             copy of the roman numeral to arabic and vice-versa functions,
  7. *--             that are contained in CONVERT.PRG. This is due to the fact
  8. *--             that only two library files may be open at one time. See
  9. *--             the file README.TXT for more details on the use of this library
  10. *--             file.
  11. *-------------------------------------------------------------------------------
  12.  
  13. PROCEDURE SCA_Real
  14. *-------------------------------------------------------------------------------
  15. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
  16. *-- Date........: 07/29/1991
  17. *-- Notes.......: This procedure was designed to handle data entered into
  18. *--               the Order of Precedence of the Principality of the Mists.
  19. *--               The problem is, my usual sources of data give only SCA
  20. *--               dates, and in order to sort properly, I need real dates.
  21. *--               This procedure will handle it, and goes hand-in-hand with
  22. *--               the function Real_SCA, to translate real dates to SCA
  23. *--               dates ... This procedure assumes that you have set the
  24. *--               F1 Key (see Example below). If you use a different F key,
  25. *--               you will want to modify the ON KEY LABEL commands ...
  26. *-- Written for.: dBASE IV, 1.1
  27. *-- Rev. History: 07/23/1991 - original procedure.
  28. *--               07/29/1991  -- modified it to stuff a character directly into
  29. *--               a date field (was having to do a CTOD in the program),
  30. *--               and added use of ESC to escape out, instead of killing
  31. *--               the procedure and the program calling it ...
  32. *-- Calls.......: CENTER               Procedure in PROC.PRG
  33. *--               SHADOW               Procedure in PROC.PRG
  34. *--               ARABIC()             Function in PROC.PRG
  35. *-- Called by...: Any
  36. *-- Usage.......: do SCA_Real
  37. *-- Example.....: on key label f1 do sca_real
  38. *--               store {} to t_date   && initialize as a date
  39. *--                                    && or you could STORE datefield to t_date
  40. *--                                    && if you have a date field ...
  41. *--               clear
  42. *--               @5,10 say "Enter a date:" get t_date;
  43. *--                  message "Press <F1> to convert from SCA date to real date"
  44. *--               read
  45. *--               on key label f1  && clear out that command ...
  46. *-- Returns.....: real date, forced into field ...
  47. *-- Parameters..: None
  48. *-------------------------------------------------------------------------------
  49.     
  50.     private cEscape,cExact,cYear,cMonth,cDay,nYearlen,nCount,nYear,nMonth
  51.     private nDay,cDate
  52.     
  53.     cEscape = set("ESCAPE")
  54.     set escape off            && so we can handle the Escape Key
  55.     cExact = set("EXACT")
  56.     set exact on              && VERY important ...
  57.     on key label F1 ?? chr(7) && make it beep, rather than call this procedure 
  58.                               && again, which causes wierdnesses ...
  59.     *-- first let's popup a window to ask for the information ...
  60.     
  61.     save screen to sDate
  62.     activate screen
  63.     define window wDate from 8,20 to 15,60 color rg+/gb,n/g,rg+/gb
  64.     do shadow with 8,20,15,60
  65.     activate window wDate
  66.     
  67.     *-- set the memvars ...
  68.     cYear  = space(8)
  69.     cMonth = space(3)
  70.     cDay   = space(2)
  71.     
  72.     do center with 0,40,"","Enter SCA Date below:"
  73.     do while .t.
  74.         
  75.         @2,14 say "Month: " get cMonth ;
  76.             picture "@M JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC";
  77.             message "Enter first letter of month, <Space> to scroll through, "+;
  78.                 "<Enter> to choose" color rg+/gb,n/g
  79.         @3,14 say "  Day: " get cDay picture "99";
  80.             message "Enter 2 digits for day of the month, if blank will assume 15";
  81.                 color rg+/gb,n/g
  82.         @4,14 say " Year: " get cYear picture "!!!!!!!!" ;
  83.             message "Enter year in AS roman numeral format";
  84.             valid required len(trim(cYear)) > 0;
  85.             error chr(7)+"This is no good without a year ..." color rg+/gb,n/g
  86.     
  87.         read
  88.     
  89.         if lastkey() = 27                && if user wants out by pressing <Esc>
  90.             deactivate window wDate
  91.             release window wDate
  92.             restore screen from sDate
  93.             release screen sDate
  94.             set escape &cEscape
  95.             set exact &cExact
  96.             on key label F1 do SCA_Real   && reset it ...
  97.             return
  98.         endif
  99.         
  100.         if lastkey() < 0   && function key F1 through Shift F9 was pressed
  101.             ?? chr(7)       && beep at user
  102.             loop            && don't let 'em get away with that -- try again
  103.         endif
  104.         
  105.         *-- check for valid roman numerals
  106.         cYear = trim(cYear)    && trim it
  107.         nYearLen = len(cYear)  && get length
  108.         nCount = 0            
  109.         do while nCount < nYearLen  && loop through length of year
  110.             nCount = nCount + 1      && increment
  111.             if .not. substr(cYear,nCount,1) $ "IVXLC" && if it's not here
  112.                 do center with 5,40,"rg+/r","** ERROR -- Invalid Year **"
  113.                 lError = .t.          && set error flag
  114.                 exit                  && exit internal loop
  115.             else
  116.                 lError = .f.          && make sure this is false
  117.             endif
  118.         enddo     && end of internal loop
  119.         if lError && if error,
  120.             loop   && go back ...
  121.         endif
  122.         
  123.         @5,0 clear   && clear out any error message ...
  124.         do center with 5,40,"rg+/r","Converting Date ..."
  125.         
  126.         *-- First (and most important) is conversion of the year
  127.         nYear = Arabic(cYear)
  128.         
  129.         *-- AS Years start at May ... if the month for a specific year is
  130.         *-- Jan through April it's part of the next "real" year ...
  131.         if cMonth = "JAN" .or. cMonth = "FEB" .or. cMonth = "MAR" .or.;
  132.                                        cMonth = "APR"
  133.             nYear = nYear + 1
  134.         endif
  135.         
  136.         nYear = nYear + 65  && SCA dates start at 66 ...
  137.         if nYear > 99       && this thing doesn't handle turn of the century
  138.             @5,0 clear
  139.             do center with 5,40,"rg+/r","No dates past XXXIV, please"
  140.             loop
  141.         endif
  142.         
  143.         *-- set numeric value of month ...
  144.         do case
  145.             case cMonth = "JAN"
  146.                 nMonth = 1
  147.             case cMonth = "FEB"
  148.                 nMonth = 2
  149.             case cMonth = "MAR"
  150.                 nMonth = 3
  151.             case cMonth = "APR"
  152.                 nMonth = 4
  153.             case cMonth = "MAY"
  154.                 nMonth = 5
  155.             case cMonth = "JUN"
  156.                 nMonth = 6
  157.             case cMonth = "JUL"
  158.                 nMonth = 7
  159.             case cMonth = "AUG"
  160.                 nMonth = 8
  161.             case cMonth = "SEP"
  162.                 nMonth = 9
  163.             case cMonth = "OCT"
  164.                 nMonth = 10
  165.             case cMonth = "NOV"
  166.                 nMonth = 11
  167.             case cMonth = "DEC"
  168.                 nMonth = 12
  169.         endcase
  170.         
  171.         *-- if the day field is empty, assume the middle of the month, so we
  172.         *-- have SOMETHING to go by ...
  173.         if len(alltrim(cDay)) = 0
  174.             nDay = 15
  175.         else
  176.             nDay = val(cDay)
  177.         endif
  178.         
  179.         *-- Check for valid day of the month ...
  180.         if nDay > 29 .and. nMonth = 2 .or. (nDay = 31 .and. (nMonth = 4 .or.;
  181.                                  nMonth = 6 .or. nMonth = 9 .or. nMonth = 11))
  182.             do center with 5,40,"rg+/r",chr(7)+"INVALID DATE -- Try again ..."
  183.             loop
  184.         endif
  185.         
  186.         exit                        && out of loop -- if here, we're done
  187.         
  188.     enddo                          && end of loop
  189.  
  190.     *-- Convert it
  191.     cDate = transform(nMonth,"@L 99")+transform(nDay,"@L 99")+;
  192.               transform(nYear,"@L 99")
  193.     
  194.     *-- force this 'character' date into the date field on the screen ...
  195.     keyboard cDate clear           && put it into the field, and clear out
  196.                                    && keyboard buffer first ...
  197.  
  198.     *-- deal with cleanup ...
  199.     deac wind wDate
  200.     release wind wDate
  201.     restore screen from sDate
  202.     release screen sDate
  203.     set escape &cEscape
  204.     set exact &cExact
  205.     on key label F1 do SCA_Real  && reset for user
  206.     
  207. RETURN
  208. *-- EoP: SCA_Real
  209.  
  210. FUNCTION SCA2Real
  211. *-------------------------------------------------------------------------------
  212. *-- Programmer..: Jay Parsons (CIS: 70160,340)
  213. *-- Date........: 04/22/1992
  214. *-- Notes.......: Jay figured out a short version of SCA_Real above, which
  215. *--               does not use screen input/screen display. This can be used
  216. *--               directly as a function.
  217. *-- Written for.: dBASE IV, 1.5
  218. *-- Rev. History: None
  219. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  220. *--               ARABIC()             Function in CONVERT.PRG (and below)
  221. *-- Called by...: Any
  222. *-- Usage.......: SCA2Real(<cDay>,<cMonth>,<cYear>)
  223. *-- Example.....: ?SCA2Real("12","JAN","XXVI")
  224. *-- Returns.....: dBASE Date (from example above: 01/12/92)
  225. *-- Parameters..: cDay   = Character day of month
  226. *--               cMonth = Character day of month
  227. *--               cYear  = Roman Numeric version of year (SCA dates)
  228. *-------------------------------------------------------------------------------
  229.  
  230.     parameters cDay, cMonth, cYear
  231.     private nMonth, nDay, nYear
  232.     
  233.     nMonth = at(upper(left(cMonth,3)),"    JAN FEB MAR APR MAY JUN";
  234.               +" JUL AUG SEP OCT NOV DEC") /4
  235.     nDay = iif(""=alltrim(cDay),15,val(cDay))
  236.     nYear = arabic(cYear)+1965+iif(nMonth < 5,1,0)
  237.     
  238. RETURN ctod(right(str(nMonth+100),2)+"/";
  239.          +right(str(nDay+100),2)+"/"+str(nYear))
  240. *-- EoF: SCA2Real()
  241.  
  242. FUNCTION Real_SCA
  243. *-------------------------------------------------------------------------------
  244. *-- Programmer..: Ken Mayer (Hirsch von Henford in the SCA) (CIS: 71333,1030)
  245. *-- Date........: 07/23/1991
  246. *-- Notes.......: This procedure was designed to handle data entered into
  247. *--               the Order of Precedence of the Principality of the Mists.
  248. *--               For the purpose of printing the Order of Precedence, it 
  249. *--               is necessary to convert real dates to SCA dates. I needed
  250. *--               to store the data as real dates, but I want it to print with
  251. *--               SCA dates ...
  252. *-- Written for.: dBASE IV, 1.1
  253. *-- Rev. History: None
  254. *-- Calls.......: ROMAN()              Function in PROC.PRG
  255. *-- Called by...: Any
  256. *-- Usage.......: Real_SCA(<dDate>)
  257. *-- Example.....: @nLine,25 say Real_SCA(CA)  && print SCA date for Corolla 
  258. *--                                           &&   Aulica
  259. *-- Returns.....: SCA Date based on dDate
  260. *-- Parameters..: dDate = date to be converted
  261. *-------------------------------------------------------------------------------
  262.  
  263.     PARAMETERS dDate   && a real date, to be converted to an SCA date ...
  264.     private nYear,nMonth,cMonth,cDay
  265.     
  266.     nYear  = year(dDate) - 1900        && remove the century
  267.     nMonth = month(dDate)
  268.     cMonth = substr(cmonth(dDate),1,3) && grab only first three characters
  269.     cDay   = ltrim(str(day(dDate)))    && convert day to character
  270.     
  271.     *-- First (and most important) is conversion of the year
  272.     *-- this is set to the turn of the century ... (AS XXXV)
  273.     *-- AS Years start at May ... if the month for a specific year is
  274.     *-- Jan through April it's part of the previous SCA year 
  275.     *-- (April '67 = April AS I, not II)
  276.      
  277.     if nMonth < 5
  278.         nYear = nYear - 1
  279.     endif
  280.     
  281.     nYear = nYear - 65   && SCA dates start at 66
  282.     cYear = Roman(nYear)
  283.  
  284. RETURN cMonth+" "+cDay+", "+"AS "+cYear
  285. *-- EoF: Real_SCA()
  286.  
  287. *-------------------------------------------------------------------------------
  288. *-- These two functions were included in this library file, so that you (or I)
  289. *-- do not have to figure a way to combine the functions below from CONVERT.PRG
  290. *-- and this file into one library file.
  291. *-------------------------------------------------------------------------------
  292.  
  293. FUNCTION Roman
  294. *-------------------------------------------------------------------------------
  295. *-- Programmer..: Nick Carlin
  296. *-- Date........: 04/26/1992
  297. *-- Notes.......: A function designed to return a Roman Numeral based on
  298. *--               an Arabic Numeral input ...
  299. *-- Written for.: dBASE III+
  300. *-- Rev. History: 04/13/1988 - original function.
  301. *--               07/25/1991 - Ken Mayer - 1) modified for dBASE IV, 1.1,
  302. *--                             2) updated to a function, and 3) the procedure
  303. *--                             GetRoman was done away with (combined into the
  304. *--                             function).
  305. *--               04/26/1992 - Jay Parsons - shortened (seriously ...)
  306. *-- Calls.......: None
  307. *-- Called by...: Any
  308. *-- Usage.......: Roman(<nArabic>)
  309. *-- Example.....: ? Roman(32)
  310. *-- Returns.....: Roman Numeral (character string) equivalent of Arabic numeral
  311. *--               passed to it. In example:  XXXII
  312. *-- Parameters..: nArabic = Arabic number to be converted to Roman
  313. *-------------------------------------------------------------------------------
  314.  
  315.    parameters nArabic
  316.    private cLetrs,nCount,nValue,cRoman,cGroup,nMod
  317.     
  318.    cLetrs ="MWYCDMXLCIVX"      && Roman digits
  319.    cRoman = ""                 && this is the returned value
  320.    nCount = 0                  && init counter
  321.    do while nCount < 4         && loop four times, once for thousands, once
  322.                                && for each of hundreds, tens and singles
  323.       nValue = mod( int( nArabic /  10 ^ ( 3 - nCount ) ), 10 )
  324.       cGroup = substr( cLetrs, nCount * 3 + 1, 3 )
  325.       nMod = mod( nValue, 5 )
  326.       if nMod = 4
  327.          if nValue = 9                 && 9
  328.             cRoman = cRoman + left( cGroup, 1 ) + right( cGroup, 1 )
  329.          else                          && 4
  330.             cRoman = cRoman + left( cGroup, 2 )
  331.          endif
  332.       else
  333.          if nValue > 4                 && 5 - 8
  334.             cRoman = cRoman + substr( cGroup, 2, 1 )
  335.          endif
  336.          if nMod > 0                   && 1 - 3 and 6 - 8
  337.             cRoman = cRoman + replicate( left( cGroup, 1 ), nMod )
  338.          endif
  339.       endif
  340.       nCount = nCount + 1
  341.    enddo  && while nCounter < 4
  342.     
  343. RETURN cRoman
  344. *-- EoF: Roman()
  345.  
  346. FUNCTION Arabic
  347. *-------------------------------------------------------------------------------
  348. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  349. *-- Date........: 04/26/1992
  350. *-- Notes.......: This function converts a Roman Numeral to an arabic one.
  351. *--               It parses the roman numeral into an array, and checks each 
  352. *--               character ... if the previous character causes the value to 
  353. *--               subtract (for example, IX = 9, not 10) we subtract that value, 
  354. *--               and then set the previous value to 0, otherwise we would get 
  355. *--               some odd values in return.
  356. *--               So far, it works fine.
  357. *-- Written for.: dBASE IV, 1.1
  358. *-- Rev. History: 07/15/1991 - original function.
  359. *--               04/26/1992 - Jay Parsons - shortened.
  360. *-- Calls.......: None
  361. *-- Called by...: Any
  362. *-- Usage.......: Arabic(<cRoman>)
  363. *-- Example.....: ?Arabic("XXIV")
  364. *-- Returns.....: Arabic number (from example, 24)
  365. *-- Parameters..: cRoman = character string containing roman numeral to be
  366. *--               converted.
  367. *-------------------------------------------------------------------------------
  368.  
  369.         parameters cRoman
  370.         private cRom,cLetrs,nLast,nAt,nVal,cChar,nArabic
  371.     
  372.         cRom = ltrim(trim(upper(cRoman))) && convert to all caps in case ...
  373.         cLetrs = "IVXLCDMWY"
  374.         nArabic = 0
  375.         nLast = 0
  376.         do while len( cRom ) > 0
  377.                 cChar = right( cRom, 1 )
  378.                 nAt = at( cChar, cLetrs )
  379.                 nVal= 10 ^ int( nAt/2 ) / iif(nAt/2 = int(nAt/2),2,1)
  380.                 do case
  381.                         case nAt = 0
  382.                                 nArabic = 0
  383.                                 exit
  384.                         case nAt >= nLast
  385.                                 nArabic = nArabic + nVal
  386.                                 nLast = nAt
  387.                         otherwise
  388.                                 if nAt/2 = int( nAt / 2 )
  389.                                         nArabic = 0
  390.                                         exit
  391.                                 else
  392.                                         nArabic = nArabic - nVal
  393.                                 endif
  394.                 endcase
  395.                 cRom = left( cRom, len( cRom ) - 1 )
  396.         enddo
  397.     
  398. RETURN nArabic
  399. *-- EoF: Arabic()
  400.  
  401. *-------------------------------------------------------------------------------
  402. *-- EoP: SCA.PRG
  403. *-------------------------------------------------------------------------------
  404.